home *** CD-ROM | disk | FTP | other *** search
/ Programmer Plus 2007 / Programmer-Plus-2007.iso / Programming / Low Level Languages / FORTRAN.500 / DISK6 / FONTS.FO$ / FONTS.bin
Encoding:
Text File  |  1990-09-28  |  3.2 KB  |  92 lines
  1. CC  FONTS.FOR - Illustrates fonts functions including:   
  2. CC              getfontinfo     setfont       unregisterfonts    
  3. CC              getgtextextent  registerfonts      
  4. CC              outgtext        setgtextvector   
  5.    
  6.    
  7.       INCLUDE  'FGRAPH.FI'   
  8.       INCLUDE  'FGRAPH.FD'   
  9.    
  10.       PARAMETER            ( NFONTS = 6 )   
  11.    
  12.       INTEGER*2            dummy, x, y, iend   
  13.       INTEGER*4            ifont   
  14.       CHARACTER*11         face(NFONTS)   
  15.       CHARACTER*10         options(NFONTS)   
  16.       CHARACTER*20         list   
  17.       CHARACTER*64         fontpath   
  18.       RECORD /videoconfig/ vc   
  19.       RECORD /xycoord/     xy   
  20.       RECORD /fontinfo/    fi   
  21.    
  22.       DATA face    / "Courier"   , "Helvetica"  , "Times Roman",   
  23.      +               "Modern"    , "Script"     , "Roman"      /   
  24.       DATA options / "t'courier'", "t'helv'"    , "t'tms rmn'" ,   
  25.      +               "t'modern'" , "t'script'"  , "t'roman'"   /   
  26.    
  27.       CALL clearscreen( $GCLEARSCREEN )   
  28.       WRITE (*,*) 'Enter file specification for .FON files'
  29.       WRITE (*,*) '[pathname\*.FON]:'   
  30.       WRITE (*,*)   
  31.       READ  (*, '(A)') fondir   
  32. C   
  33. C     Locate .FON files, then register fonts by reading header   
  34. C     information from all files.   
  35. C   
  36.       IF( registerfonts( '*.FON' ). LT. 0 ) THEN   
  37.          WRITE (*, '(A/)') ' Enter directory for .FON files:'   
  38.          READ (*, '(A )') fontpath   
  39.          iend = INDEX( fontpath, ' ' )   
  40.          fontpath( iend:iend + 5 ) = '\*.FON'   
  41.          IF( registerfonts( fontpath ). LT. 0 )   
  42.      +      STOP 'Error: cannot find font files'   
  43.       ENDIF   
  44.    
  45. C   
  46. C     Find graphics mode.   
  47. C   
  48.       IF( setvideomode( $MAXRESMODE ) .EQ. 0 )    
  49.      +    STOP 'Error:  cannot set graphics mode'   
  50.       CALL getvideoconfig( vc )   
  51.    
  52. C   
  53. C     Display each font name centered on screen.   
  54. C   
  55.       DO ifont = 1, NFONTS   
  56.    
  57. C   
  58. C        Build options string.   
  59. C   
  60.          list = options(ifont) // 'h30w24b'    
  61.    
  62.          CALL clearscreen( $GCLEARSCREEN )   
  63.          IF( setfont( list ) .GE. 0 ) THEN   
  64. C   
  65. C           Use length of text and height of font to center text.   
  66. C   
  67.             x = (vc.numxpixels-getgtextextent   
  68.      +           (face( ifont))) / 2   
  69.             IF( getfontinfo( fi ) .NE. 0 ) THEN   
  70.                CALL outtext( 'Error:  cannot get font info' )   
  71.                READ (*,*)   
  72.             END IF   
  73.             y = (vc.numypixels - fi.ascent) / 2   
  74.             CALL moveto( x, y, xy )   
  75.             IF( vc.numcolors .GT. 2 ) dummy = setcolor( ifont )    
  76.             CALL setgtextvector( 1, 0 )   
  77.             CALL outgtext( face(ifont))   
  78.             CALL setgtextvector( 0, 1 )   
  79.             CALL outgtext( face(ifont))   
  80.             CALL setgtextvector( -1, 0 )   
  81.             CALL outgtext( face(ifont))   
  82.             CALL setgtextvector( 0, -1 )   
  83.             CALL outgtext( face(ifont))    
  84.          ELSE   
  85.             CALL outtext( 'Error:  cannot set font' )   
  86.          END IF   
  87.          READ (*,*)   
  88.       END DO   
  89.       CALL unregisterfonts()   
  90.       dummy = setvideomode( $DEFAULTMODE )   
  91.       END   
  92.